(DEFUN DMAC () (LIST '/!/, (READ) '(GENV)))
(DEFUN GENV () (READLIST (CONS '* (EXPLODE (SETQ GENV (1+ GENV))))))
(SETQ GENV 0)
(SSTATUS MACRO /$ 'DMAC)

(IF-NEEDED I-F-ON (IMPERATIVE-FOR (ON !X !Y))
   (TO-MAKE (ON !,X !,Y)
      (NEEDS (AND (CLEARTOP !,X) (SPACE-FOR !,X !,Y))
         (PUTON X Y)))
   (ADIEU 'OK))

(IF-NEEDED M-O-CLEARTOP
   (MEANING-OF (CLEARTOP !'X) (NOT (EXISTS $Y (ON !,Y !,X))))
   (NOTE))

(IF-NEEDED S-F-NOT-ON
   (SUFFICES-FOR (NOT (ON !'X !'Y))
      (EXISTS $Z (WHERE (ON !,X !,Z) (NOT (= !,Z !,Y)))))
   (NOTE))

(IF-NEEDED M-H-SPACE-FOR-1
   (MAY-HURT (SPACE-FOR !'X !'Y) (CLUTTERED !,Y))
   (NOTE))

(IF-NEEDED M-H-SPACE-FOR-2
   (MAY-HURT (SPACE-FOR !'X !'Y) (HAPHAZARD !,Y))
   (NOTE))

(IF-NEEDED M-O-CLUTTERED
   (MEANING-OF (CLUTTERED !'X) 
      (EXISTS $Y (WHERE (ON !,Y !,X) (NOT (PROTECTED (ON !,Y !,X))))))
   (NOTE))

(IF-NEEDED M-O-HAPHAZARD
   (MEANING-OF (HAPHAZARD !'X)
      (EXISTS $Y (BADLY-PLACED !,Y !,X)))
   (NOTE))

(IF-NEEDED S-F-NOT-BADLY-PLACED
   (SUFFICES-FOR (NOT (BADLY-PLACED !'X !'Y)) (PACKED !,X !,Y))
   (NOTE))

(IF-NEEDED I-F-PACKED (IMPERATIVE-FOR (PACKED !X !Y))
   (TO-MAKE (PACKED !,X !,Y)
      (NEEDS (AND (ON !,X !,Y) (CLEARTOP !,X))
         (PACK X Y)))
   (ADIEU 'OK))

(IF-NEEDED P-ON (POSSIBLE (ON !X !!SURF))
   (CSETQ SURF 'TABLE) (AU-REVOIR (INSTANCE))
   (TRUE1 '(FLATTOPED !SURF)))

(SSTATUS MACRO /$ NIL)

(IF-NEEDED T-O-S (SPACE-FOR !X !Y)
   (COND ((FINDSPACE X Y) (ADIEU T))))

(IF-NEEDED T-O-BP (BADLY-PLACED !?X !?Y)
   (COND ((PRESENT '(OCCUPIED CENTER !;X !;Y)) (NOTE))))(DEFUN FINDSPACE (OBJ SURF)
   (COND ((EQ SURF 'TABLE) (GENSYM))
         ((PRESENT !"(OCCUPIED CENTER ! @SURF)) NIL)
         ((PRESENT !"(OCCUPIED RIGHT ! @SURF))
          (COND ((PRESENT !"(OCCUPIED LEFT ! @SURF)) NIL) (T 'LEFT)))
         ((PRESENT !"(OCCUPIED LEFT ! @SURF)) 'RIGHT)
         (T 'CENTER)))

(DEFUN BESTPACK (OBJ SURF) 'RIGHT)

(DEFUN MOVE (OBJ SURF1 SURF2 PLACE)
   (COND ((PRESENT !"(OCCUPIED !P @OBJ @SURF1))
          (KILL !"(OCCUPIED ,P @OBJ @SURF1))))
   (INSERT !"(OCCUPIED @PLACE @OBJ @SURF2))
   (PRINT !"(MOVING @OBJ FROM @SURF1 TO @SURF2 @PLACE)))

(DEFUN PUSH (OBJ PLACE SURF)
   (COND ((PRESENT !"(OCCUPIED !P @OBJ @SURF))
          (KILL !"(OCCUPIED ,P @OBJ @SURF))))
   (INSERT !"(OCCUPIED @PLACE @OBJ @SURF))
   (PRINT !"(PUSHING @OBJ TO @PLACE ON @SURF)))

(CDEFUN PUTON (OBJ SURF) "AUX"(S X (CONTEXT (PUSH-CONTEXT)))
   (COND ((ATOM OBJ)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,OBJ))))
   (COND ((ATOM SURF)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,SURF))))
   (COND ((PRESENT !"(ON !X ,OBJ))
          (BUG UNSATISFIED-PREREQUISITE (NOT (ON ,X ,OBJ)))))
   (COND ((CSETQ X (FINDSPACE OBJ SURF)))
         (T (BUG UNSATISFIED-PREREQUISITE (SPACE-FOR ,OBJ ,SURF))))
   (COND ((PRESENT !"(ON ,OBJ !S)) (REMOVE !"(ON ,OBJ ,S)))
         (T (CSETQ S 'SOURCE)))
   (ADD !"(ON ,OBJ ,SURF))
   (CHECK-PROTECTEDS)
   (CSET 'CONTEXT CONTEXT (ACCESS))
   (MOVE OBJ S SURF X)
   (WINTEST)
   'OK)

(CDEFUN PACK (OBJ SURF) "AUX"(S X (CONTEXT (PUSH-CONTEXT)))
   (COND ((ATOM OBJ)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,OBJ))))
   (COND ((ATOM SURF)) (T (BUG INAPPLICABLE-PRIMITIVE (ATOM ,SURF))))
   (COND ((PRESENT !"(ON !X ,OBJ))
          (BUG UNSATISFIED-PREREQUISITE (NOT (ON ,X ,OBJ)))))
   (COND ((PRESENT !"(ON ,OBJ ,SURF)))
         (T (BUG UNSATISFIED-PREREQUISITE (ON ,OBJ ,SURF))))
   (CSETQ X (BESTPACK OBJ SURF))
   (CSET 'CONTEXT CONTEXT (ACCESS))
   (PUSH OBJ X SURF)
   (WINTEST)
   'OK)



ββββββββββββββββ